home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DIRS.SWG / 0001_ForEachFile Procedure.pas next >
Pascal/Delphi Source File  |  1993-05-28  |  4KB  |  165 lines
  1. {
  2.  Can any one tell me a way to make pascal (TP 6.0) search a
  3.  complete drive, including all subdirectories, even ones
  4.  that are not in the path, looking For a specific File
  5.  extension?  I.E., having the Program search For *.DOC and
  6.  saving that to a Text File?
  7.  
  8.  Here's part of a package I'm putting together.  You'd use it like this:
  9.  
  10. }
  11.  
  12. {File Test.Pas}
  13.  
  14. Uses
  15.   Dos, Foreach;
  16.  
  17. Procedure PrintAllDocs;
  18.  
  19.   Procedure PrintFile(Var Dir: DirStr; Var S : SearchRec); Far;
  20.   begin
  21.     Writeln('Found File ',Dir,S.Name);
  22.   end;
  23.  
  24. begin
  25.   ForEachFile('c:\*.doc',  { Give the mask where you want to start looking }
  26.               0, 0,        { Specify File attributes here; you'll just get
  27.                              normal Files With 0 }
  28.               True,        { Search recursively }
  29.               @PrintFile); { Routine to call For each File }
  30. end;
  31.  
  32. begin
  33.   PrintAllDocs;
  34. end.
  35.  
  36.  
  37. {Unit ForEach}
  38.  
  39. Unit ForEach;
  40.  
  41. { Unit With a few different "foreach" Functions. }
  42. { This extract contains only ForEachFile. }
  43.  
  44. Interface
  45.  
  46. Uses
  47.   Dos;
  48.  
  49. Type
  50.   FileStr = String[12];
  51.   TFileAction = Procedure(Var Dir : DirStr;
  52.                           Var S : SearchRec; ConText : Word);
  53.  
  54. Procedure ForEachFile(Mask : PathStr; { File wildcard mask, including path }
  55.                       Attr : Byte; { File attributes }
  56.                       Match : Byte; { File attributes which
  57.                                              must match attr exactly }
  58.                       Subdirs : Boolean; { Whether to search recursively }
  59.                       Action : Pointer);
  60. { Calls the Far local Procedure Action^ For each File found.
  61.   Action^ should be a local Procedure With declaration
  62.     Procedure Action(Var Path : String; Var S : SearchRec); Far;
  63.   or, if not a local Procedure,
  64.     Procedure Action(Var Path : String; Var S : SearchRec; Dummy : Word); Far;
  65.   Each time Action is called S will be filled in For a File matching
  66.   the search criterion.
  67. }
  68.  
  69. Implementation
  70.  
  71. Function CallerFrame : Word;
  72. { Returns the BP value of the caller's stack frame; used For passing
  73.   local Procedures and Functions around. Taken from Borland's Outline
  74.   Unit. }
  75.   Inline(
  76.     $8B/$46/$00                   { MOV   AX,[BP] }
  77.     );
  78.  
  79.  
  80.   { ******** File routines ********* }
  81.  
  82. Procedure ForEachFile(Mask    : PathStr; { File wildcard mask }
  83.                       Attr    : Byte;    { File attributes }
  84.                       Match   : Byte;    { Attributes which must match }
  85.                       Subdirs : Boolean; { Whether to search recursively }
  86.                       Action  : Pointer);{ Action; should point to
  87.                                            a TFileAction local Far Procedure }
  88. Var
  89.   CurrentDir : DirStr;
  90.   Doit       : TFileAction Absolute Action;
  91.   Frame      : Word;
  92.  
  93.   Procedure DoDir;
  94.   { Tests all Files in current directory.  Assumes currentdir has trailing
  95.     backslash }
  96.   Var
  97.     S : SearchRec;
  98.   begin
  99.     FindFirst(CurrentDir + Mask, Attr, S);
  100.     While DosError = 0 do
  101.     begin
  102.       if (S.Attr and Match) = (Attr and Match) then
  103.         Doit(CurrentDir, S, Frame);
  104.       FindNext(S);
  105.     end;
  106.   end;
  107.  
  108.   Function RealDir(Name : FileStr) : Boolean;
  109.   begin
  110.     RealDir := (Name <> '.') and (Name <> '..');
  111.   end;
  112.  
  113.   Procedure AddBackslash;
  114.   begin
  115.     CurrentDir := CurrentDir + '\';
  116.   end;
  117.  
  118.   Procedure DoAllDirs;
  119.   Var
  120.     S         : SearchRec;
  121.     OldLength : Byte;
  122.  
  123.     Procedure AddSuffix(Suffix : FileStr); { Separate proc to save stack space }
  124.     begin
  125.       CurrentDir := Copy(CurrentDir, 1, OldLength) + Suffix;
  126.     end;
  127.  
  128.   begin
  129.     OldLength := Length(CurrentDir);
  130.     DoDir;
  131.     AddSuffix('*.*');
  132.     FindFirst(CurrentDir, Directory, S);
  133.     While DosError = 0 do
  134.     begin
  135.       if S.Attr = Directory then
  136.       begin
  137.         if RealDir(S.Name) then
  138.         begin
  139.           AddSuffix(S.Name);
  140.           AddBackslash;
  141.           DoAllDirs;            { do directory recursively }
  142.         end;
  143.       end;
  144.       FindNext(S);
  145.     end;
  146.   end;
  147.  
  148. Var
  149.   Name : NameStr;
  150.   Ext  : ExtStr;
  151.  
  152. begin                           { ForEachFile }
  153.   FSplit(Mask, CurrentDir, Name, Ext);
  154.   Mask := Name+Ext;
  155.   Frame := CallerFrame;
  156.   if CurrentDir[Length(CurrentDir)] <> '\' then
  157.     AddBackslash;
  158.   if Subdirs then
  159.     DoAllDirs
  160.   else
  161.     DoDir;
  162. end;
  163.  
  164. end.
  165.